home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / WIN_PRO / DS-1.ZIP;1 / RUNTIME.ZIP / OMISC.R < prev    next >
Encoding:
Text File  |  1992-02-10  |  5.9 KB  |  270 lines
  1. /*
  2.  * File: omisc.r
  3.  *  Contents: refresh, size, tabmat, toby, to, llist
  4.  */
  5.  
  6. "^x - create a refreshed copy of a co-expression."
  7. #ifdef Coexpr
  8. /*
  9.  * ^x - return an entry block for co-expression x from the refresh block.
  10.  */
  11. operator{1} ^ refresh(x)
  12.    if !is:co_expression(x) then
  13.        runerr(118, x)
  14.    abstract {
  15.       return co_expression
  16.       }
  17.  
  18.    body {
  19.       register struct b_coexpr *sblkp;
  20.  
  21.       /*
  22.        * Get a new co-expression stack and initialize.
  23.        */
  24.       Protect(sblkp = alccoexp(), runerr(0));
  25.  
  26.       sblkp->freshblk = BlkLoc(x)->coexpr.freshblk;
  27.       if (ChkNull(sblkp->freshblk))    /* &main cannot be refreshed */
  28.          runerr(215, x);
  29.  
  30.       /*
  31.        * Use refresh block to finish initializing the new co-expression.
  32.        */
  33.       co_init(sblkp);
  34.  
  35. #if COMPILER
  36.       sblkp->fnc = BlkLoc(x)->coexpr.fnc;
  37.       if (line_info) {
  38.          if (debug_info)
  39.             PFDebug(sblkp->pf)->proc = PFDebug(BlkLoc(x)->coexpr.pf)->proc;
  40.          PFDebug(sblkp->pf)->old_fname =
  41.             PFDebug(BlkLoc(x)->coexpr.pf)->old_fname;
  42.          PFDebug(sblkp->pf)->old_line =
  43.             PFDebug(BlkLoc(x)->coexpr.pf)->old_line;
  44.          }
  45. #endif                    /* COMPILER */
  46.  
  47.       return co_expression(sblkp);
  48.       }
  49. #else                    /* Coexpr */
  50. operator{} ^ refresh(x)
  51.       runerr(401)
  52. #endif                    /* Coexpr */
  53.  
  54. end
  55.  
  56.  
  57. "*x - return size of string or object x."
  58.  
  59. operator{1} * size(x)
  60.    abstract {
  61.       return integer
  62.       }
  63.    type_case x of {
  64.       string: inline {
  65.          return C_integer StrLen(x);
  66.          }
  67.       list: inline {
  68.          return C_integer BlkLoc(x)->list.size;
  69.          }
  70.       table: inline {
  71.          return C_integer BlkLoc(x)->table.size;
  72.          }
  73.       set: inline {
  74.          return C_integer BlkLoc(x)->set.size;
  75.          }
  76.       cset: inline {
  77.          register word i;
  78.  
  79.          i = BlkLoc(x)->cset.size;
  80.      if (i < 0)
  81.         i = cssize(&x);
  82.          return C_integer i;
  83.          }
  84.       record: inline {
  85.          return C_integer BlkLoc(x)->record.recdesc->proc.nfields;
  86.          }
  87.       co_expression: inline {
  88.          return C_integer BlkLoc(x)->coexpr.size;
  89.          }
  90.       default: {
  91.          /*
  92.           * Try to convert it to a string.
  93.           */
  94.          if !cnv:tmp_string(x) then
  95.             runerr(112, x);    /* no notion of size */
  96.          inline {
  97.         return C_integer StrLen(x);
  98.             }
  99.          }
  100.       }
  101. end
  102.  
  103.  
  104. "=x - tab(match(x)).  Reverses effects if resumed."
  105.  
  106. operator{*} = tabmat(x)
  107.    /*
  108.     * x must be a string.
  109.     */
  110.    if !cnv:string(x) then
  111.       runerr(103, x)
  112.    abstract {
  113.       return string
  114.       }
  115.  
  116.    body {
  117.       register word l;
  118.       register char *s1, *s2;
  119.       C_integer i, j;
  120.       /*
  121.        * Make a copy of &pos.
  122.        */
  123.       i = k_pos;
  124.  
  125.       /*
  126.        * Fail if &subject[&pos:0] is not of sufficient length to contain x.
  127.        */
  128.       j = StrLen(k_subject) - i + 1;
  129.       if (j < StrLen(x))
  130.          fail;
  131.  
  132.       /*
  133.        * Get pointers to x (s1) and &subject (s2).  Compare them on a bytewise
  134.        *  basis and fail if s1 doesn't match s2 for *s1 characters.
  135.        */
  136.       s1 = StrLoc(x);
  137.       s2 = StrLoc(k_subject) + i - 1;
  138.       l = StrLen(x);
  139.       while (l-- > 0) {
  140.          if (*s1++ != *s2++)
  141.             fail;
  142.          }
  143.  
  144.       /*
  145.        * Increment &pos to tab over the matched string and suspend the
  146.        *  matched string.
  147.        */
  148.       l = StrLen(x);
  149.       k_pos += l;
  150.       suspend x;
  151.  
  152.       /*
  153.        * tabmat has been resumed, restore &pos and fail.
  154.        */
  155.       if (i > StrLen(k_subject) + 1)
  156.          runerr(205, kywd_pos);
  157.       else
  158.          k_pos = i;
  159.       fail;
  160.       }
  161. end
  162.  
  163.  
  164. "i to j by k - generate successive values."
  165.  
  166. operator{*} ... toby(from, to, by)
  167.    /*
  168.     * arguments must be integers.
  169.     */
  170.    if !cnv:C_integer(from) then
  171.       runerr(101, from)
  172.    if !cnv:C_integer(to) then
  173.       runerr(101, to)
  174.    if !cnv:C_integer(by) then
  175.       runerr(101, by)
  176.  
  177.    abstract {
  178.       return integer
  179.       }
  180.  
  181.    inline {
  182.       /*
  183.        * by must not be zero.
  184.        */
  185.       if (by == 0) {
  186.          irunerr(211, by);
  187.          errorfail;
  188.          }
  189.  
  190.       /*
  191.        * Count up or down (depending on relationship of from and to) and
  192.        *  suspend each value in sequence, failing when the limit has been
  193.        *  exceeded.
  194.        */
  195.       if (by > 0)
  196.          for ( ; from <= to; from += by) {
  197.             suspend C_integer from;
  198.             }
  199.       else
  200.          for ( ; from >= to; from += by) {
  201.             suspend C_integer from;
  202.             }
  203.       fail;
  204.       }
  205. end
  206.  
  207.  
  208. "i to j - generate successive values."
  209.  
  210. operator{*} ... to(from, to)
  211.    /*
  212.     * arguments must be integers.
  213.     */
  214.    if !cnv:C_integer(from) then
  215.       runerr(101, from)
  216.    if !cnv:C_integer(to) then
  217.       runerr(101, to)
  218.  
  219.    abstract {
  220.       return integer
  221.       }
  222.  
  223.    inline {
  224.       for ( ; from <= to; ++from) {
  225.          suspend C_integer from;
  226.          }
  227.       fail;
  228.       }
  229. end
  230.  
  231.  
  232. " [x1, x2, ... ] - create an explicitly specified list."
  233.  
  234. operator{1} [...] llist(elems[n])
  235.    abstract {
  236.       return new list(type(elems))
  237.       }
  238.    body {
  239.       tended struct b_list *hp;
  240.       register word i;
  241.       register struct b_lelem *bp;  /* need not be tended */
  242.       word nslots;
  243.  
  244.       nslots = n;
  245.       if (nslots == 0)
  246.          nslots = MinListSlots;
  247.    
  248.       /*
  249.        * Allocate the list and a list block.
  250.        */
  251.       Protect(hp = alclist(n), runerr(0));
  252.       Protect(bp = alclstb(nslots, (word)0, n), runerr(0));
  253.    
  254.       /*
  255.        * Make the list block just allocated into the first and last blocks
  256.        *  for the list.
  257.        */
  258.       hp->listhead = hp->listtail = (union block *)bp;
  259.  
  260.       /*
  261.        * Assign each argument to a list element.
  262.        */
  263.       for (i = 0; i < n; i++)
  264.          bp->lslots[i] = elems[i];
  265.    
  266.       return list(hp);
  267.       }
  268. end
  269.  
  270.